Attribute VB_Name = "modScalePic"
Option Explicit

Public Type CHAR_ASSOC
    red As Integer
    green As Integer
    blue As Integer
    Char As String
End Type

Public theChars() As CHAR_ASSOC
Public threshold As Integer
Public isColored As Boolean

Public Sub ScalePicture(PB As PictureBox)
    Dim lngHeightB, lngWidthB As Long
    Dim lngHeightP, lngWidthP As Long
    Dim lngNewHeight, lngNewWidth As Long
    With PB
        PB.ScaleMode = vbPixels
        lngWidthB = PB.ScaleWidth
        lngWidthP = PB.ScaleX(.Picture.Width, vbHimetric, vbPixels)
        lngHeightB = PB.ScaleHeight
        lngHeightP = PB.ScaleY(.Picture.Height, vbHimetric, vbPixels)
        .Cls
        If (lngWidthB < lngWidthP) Or (lngHeightB < lngHeightP) Then
            If (lngWidthP >= lngHeightP) Then
                lngNewWidth = lngWidthB
                lngNewHeight = (lngHeightP / lngWidthP) * lngWidthB
            Else
                lngNewWidth = (lngWidthP / lngHeightP) * lngHeightB
                lngNewHeight = lngHeightB
            End If
            If lngNewWidth > lngWidthB Then
                lngNewWidth = lngWidthB
                lngNewHeight = (lngHeightP / lngWidthP) * lngWidthB
            ElseIf lngNewHeight > lngHeightB Then
                lngNewWidth = (lngWidthP / lngHeightP) * lngHeightB
                lngNewHeight = lngHeightB
            End If
            If lngWidthB > 0 And lngHeightB > 0 Then
                .PaintPicture .Picture, 0, 0, lngWidthB, lngHeightB, 0, 0, 1, 1, vbSrcCopy
                .PaintPicture .Picture, 0, 0, lngNewWidth, lngNewHeight, 0, 0, lngWidthP, lngHeightP, vbSrcCopy
            End If
        End If
        .Refresh
    End With
End Sub
